(* ::Package:: *)

(* ::Subsection:: *)
(*Import KnotTheory*)


(* ::Input::Initialization:: *)
Needs["KnotTheory`"]


(* ::Subsubsection:: *)
(*PD Tool Box*)


(* ::Input::Initialization:: *)
AttachedCrossings[thisArc_Integer,crossings_List]:= Cases[crossings,X[___,thisArc,___]];
AttachedCrossings[thisArc_Integer,pd_PD]:=AttachedCrossings[thisArc,List@@pd];
AttachedCrossings[arcs_List,crossings_List]:=Union@@Map[AttachedCrossings[#,crossings]&,arcs];
AttachedCrossings[arcs_List,pd_PD]:=AttachedCrossings[arcs,List@@pd];
AttachedCrossings[arcs_,signedPD_Association]:=AttachedCrossings[arcs,Keys[signedPD]];

Arcs[pd_PD]:=Union@@Table[List@@x,{x,List@@pd}];


(* ::Subsubsection:: *)
(*For Link*)


(* ::Input::Initialization:: *)
(* Added LinkRot to be compatible with Links*)
OppoArc[arc_Integer,x_X]:=x[[Mod[Position[x,arc][[1,1]] +1,4]+1]];
OppoArcs[arc_Integer,pd_PD]:=OppoArc[arc,#]&/@AttachedCrossings[arc,pd];

LinkComponents[pd_PD]:=Module[{arcs = Arcs[pd],comps = {},newComp ,tmp,j,thisArc,nextArc,endArc},
Do[
If[FreeQ[comps,i],
	thisArc = i;
	If[Length[OppoArcs[i,pd]]==1,
	{nextArc} = OppoArcs[i,pd];
	endArc = Max[arcs],
	{nextArc,endArc} = OppoArcs[i,pd]];
	newComp = Union[{i,endArc},{nextArc}];
	While[nextArc != endArc && nextArc != 2Length[pd]+1,
	tmp = nextArc;
	nextArc = Select[OppoArcs[nextArc,pd],#!= thisArc&][[1]];
	thisArc = tmp;
	newComp = Union[newComp,{nextArc}]
	];
	comps = Append[comps,newComp];]
,{i,arcs}];
comps
];

(* Establish a coherent orientation on the given PD and returns the crossings associated with their signs *)
EstablishSign[pd_PD]:=Module[{signAssoc = <||>, comps = LinkComponents[pd] ,comps2Arc,xs,thisX,anotherX, outArcs,madeX},
comps2Arc = Select[comps,Length[#]==2&];
Do[
xs = AttachedCrossings[comp[[1]],pd];
thisX = Select[xs, MemberQ[comp,#[[1]]]&][[1]];
anotherX = Complement[xs,{thisX}][[1]];

If[Length[Select[Keys[signAssoc],Length[#\[Intersection]thisX] == 4&]]==0,
If[PositiveQ[thisX],
outArcs = {OppoArc[thisX[[1]],thisX],OppoArc[thisX[[4]],thisX]};
madeX = X[outArcs[[2]],OppoArc[outArcs[[1]],anotherX] ,OppoArc[outArcs[[2]],anotherX] ,outArcs[[1]]]
,
outArcs = {OppoArc[thisX[[2]],thisX],OppoArc[thisX[[1]],thisX]};
madeX = X[outArcs[[1]],outArcs[[2]],OppoArc[outArcs[[1]],anotherX],OppoArc[outArcs[[2]],anotherX]]
];

AppendTo[signAssoc, thisX -> PositiveQ[thisX]];
AppendTo[signAssoc, madeX -> PositiveQ[thisX]](*Here we assumed that no Redemeister move II could have been performed*)
];
,{comp,comps2Arc}];

Do[
If[Length[Select[Keys[signAssoc],Length[#\[Intersection]x] == 4&]]==0,
signAssoc = Append[signAssoc, x -> 
If[FreeQ[{x[[2]],x[[4]]},2Length[pd]+1],
PositiveQ[x], 
PositiveQ[Replace[x, 2Length[pd]+1 -> OppoArc[2Length[pd]+1,x]+1,1]] ]]
]
,{x,List@@pd}];
signAssoc
];

EntranceArcs[x_X,signedPD_Association]:=If[signedPD[x],
{x[[4]],x[[1]]},
{x[[1]],x[[2]]}
];

EntranceCrossing[thisArc_Integer,signedPD_Association]:=Module[{attached = AttachedCrossings[thisArc,signedPD],ans},
Do[If[MemberQ[EntranceArcs[x,signedPD],thisArc],
ans = x
]
,{x,attached}];
ans
];

(* LinkRot handles pd as if they are their corresponding longPD cut at arc 1. 
The entrance depends on how the signs were established, and the rot number for the exit arc is neglected *)
LinkRot[signedPD_Association]:=Module[{n=Length@signedPD,x,rots,tmpX,front={1},tmpArcs,toDoArcs = Arcs[PD@@Keys[signedPD]],k,NextArc},
rots =Table[0,{2n}];

NextArc[]:=Min[front\[Intersection]toDoArcs];

Do[
k =NextArc[];

If[FreeQ[front,-k],
tmpX =EntranceCrossing[k,signedPD];
tmpArcs = EntranceArcs[tmpX,signedPD];
If[tmpArcs[[1]] == k,
front = Flatten@Replace[front,k-> {OppoArc[tmpArcs[[2]],tmpX],OppoArc[tmpArcs[[1]],tmpX],-tmpArcs[[2]]},{1}],
++rots[[tmpArcs[[1]]]];
front = Flatten@Replace[front,k-> {-tmpArcs[[1]],OppoArc[tmpArcs[[2]],tmpX],OppoArc[tmpArcs[[1]],tmpX]},{1}]
],
Cases[front,k|-k]/.{k,-k}:>--rots[[k]];
];

toDoArcs = DeleteCases[toDoArcs,k]
,{j,1,2n}];

rots
];
LinkRot[pd_PD]:=LinkRot[EstablishSign[pd]];
LinkRot[K_]:=LinkRot[PD[K]];
